(in-package :cl-user)

(defun generate (pathname &aux (count 0))
  (labels (
    (cwrite (obj stream)
      (etypecase obj
        (null
          (format stream "nil") )
        (symbol
          (let ((pkg (symbol-package obj)))
            (cond
              ((eq obj 't) (write-char #\t stream))
              ((find-class obj nil)
                (let ((s (symbol-name obj)))
                  (write-char #\Q stream)
                  (loop for ch across s do
                    (if (alphanumericp ch)
                        (write-char (char-downcase ch) stream)
                      (write-char #\_ stream) )) ) )
              ((or (eq (find-package :cl) pkg)
                   (eq (find-package :si) pkg)
                   (eq (find-package :ext) pkg)
                   (eq (find-package :clos) pkg) )
                (format stream "Q(\"~A\")" (symbol-name obj)) )
              ((eq (find-package :keyword) pkg)
                (format stream "Q(\":~A\")" (symbol-name obj)) )
              (t
                (format stream "Q(\"~A:~A\")"
                  (first (package-nicknames pkg))
                  (symbol-name obj) ) )) ) )
        (number
          (format stream "Fixnum::Encode(~D)" (truncate obj)) )
        (si::setf-cell
          (format stream "intern_setf_cell(Q(\"~A\"))"
            (ext:ref si::setf-cell si::name obj) ) )
        (cons
          (if (>= (length obj) 7)
              (progn
                (format stream "cons(")
                (cwrite (car obj) stream)
                (format stream ", ")
                (cwrite (cdr obj) stream)
                (format stream ")") )
            (let ((comma "("))
              (format stream "list")
              (dolist (elt obj)
                (write-string comma stream)
                (cwrite elt stream)
                (setq comma ", ") )
              (format stream ")") )) )) )

    ;; write-ftype
    (write-ftype (fname stream)
      (multiple-value-bind (type local-p alist)
          (c::function-information fname)
          (declare (ignore type local-p))
        (let ((ftype (cdr (assoc 'ftype alist))))
          (when ftype
            (incf count)
            (cond
              ((not (consp ftype))
                (format t "Alias ftype ~S: ~S~%" fname ftype)
                (when (eq ftype 'si::predicate)
                  (setq ftype '(function (t) t)) ) )
              ((/= (length ftype) 3)
                (format t "Malformed ftype for ~S: ~S~%" fname ftype) )
              ((null (third ftype))
                (format t "Nil value ~S: ~S~%" fname ftype) ))
            (let ((sym
                    (if (symbolp fname)
                        fname
                      (si::intern-setf-cell (second fname)) ) ))
              (format stream "  // ~(~S ~S~)~%" fname ftype)
              (format stream "  add_ftype(")
              (cwrite sym stream)
              (format stream ",~%    ")
              (cwrite (second ftype) stream)
              (format stream ",~%    ")
              (cwrite (third ftype) stream)
              (format stream " );~2%") ) ) ) ) )


    ;; write-header
    (write-header (out)
      (format out "// This file is automatically generated at:~%")
      (format out "//  ~{~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D~}~%"
        (multiple-value-bind (s n h d m y) (get-decoded-time)
            (list y m d h n s) ) )
      (format out "//~%")
      (format out "// DO NOT EDIT THIS FILE!~%")
      (format out "//~%") )
    )
    (with-open-file (stream pathname :direction :output :if-exists :supersede)
      (write-header stream)
      (do-external-symbols (sym (find-package :cl) count)
        (write-ftype sym stream)
        (write-ftype `(setf ,sym) stream) ) ) ) )

(format t "~2%Type~%~4T~(~S~)~2%"
    '(generate "/proj/evcl3/compiler/boot/cm_bt_ftype_cl.inc") )

(format t "This function must return 636+65=~D.~%" (+ 636 65))

